home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / gnus-vis.el.z / gnus-vis.el
Encoding:
Text File  |  1998-10-28  |  58.1 KB  |  1,608 lines
  1. ;;; gnus-vis.el --- display-oriented parts of Gnus
  2. ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Per Abrahamsen <abraham@iesd.auc.dk>
  6. ;; Keywords: news
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;;; Code:
  28.  
  29. (require 'gnus)
  30. (require 'gnus-ems)
  31. (require 'easymenu)
  32. (require 'custom)
  33. (require 'browse-url)
  34. (require 'gnus-score)
  35. (eval-when-compile (require 'cl))
  36.  
  37. (defvar gnus-group-menu-hook nil
  38.   "*Hook run after the creation of the group mode menu.")
  39.  
  40. (defvar gnus-summary-menu-hook nil
  41.   "*Hook run after the creation of the summary mode menu.")
  42.  
  43. (defvar gnus-article-menu-hook nil
  44.   "*Hook run after the creation of the article mode menu.")
  45.  
  46. ;;; Summary highlights.
  47.  
  48. ;(defvar gnus-summary-highlight-properties
  49. ;  '((unread "ForestGreen" "green")
  50. ;    (ticked "Firebrick" "pink")
  51. ;    (read "black" "white")
  52. ;    (low italic italic)
  53. ;    (high bold bold)
  54. ;    (canceled "yellow/black" "black/yellow")))
  55.  
  56. ;(defvar gnus-summary-highlight-translation
  57. ;  '(((unread (= mark gnus-unread-mark))
  58. ;     (ticked (or (= mark gnus-ticked-mark) (= mark gnus-dormant-mark)))
  59. ;     (read (not (or (= mark gnus-unread-mark) (= mark gnus-dormant-mark)
  60. ;            (= mark gnus-ticked-mark) (= mark gnus-canceled-mark))))
  61. ;     (canceled (= mark gnus-canceled-mark)))
  62. ;    ((low (< score gnus-summary-default-score))
  63. ;     (high (> score gnus-summary-default-score)))))
  64.  
  65. ;(defun gnus-visual-map-face-translation ()
  66. ;  (let ((props gnus-summary-highlight-properties)
  67. ;    (trans gnus-summary-highlight-translation)
  68. ;    map)
  69. ;    (while props)))
  70.       
  71. ;see gnus-cus.el
  72. ;(defvar gnus-summary-selected-face 'underline
  73. ;  "*Face used for highlighting the current article in the summary buffer.")
  74.  
  75. ;see gnus-cus.el
  76. ;(defvar gnus-summary-highlight
  77. ;  (cond ((not (eq gnus-display-type 'color))
  78. ;     '(((> score default) . bold)
  79. ;       ((< score default) . italic)))
  80. ;    ((eq gnus-background-mode 'dark)
  81. ;     (list (cons '(= mark gnus-canceled-mark)
  82. ;             (custom-face-lookup "yellow" "black" nil nil nil nil))
  83. ;           (cons '(and (> score default) 
  84. ;               (or (= mark gnus-dormant-mark)
  85. ;                   (= mark gnus-ticked-mark)))
  86. ;             (custom-face-lookup "pink" nil nil t nil nil))
  87. ;           (cons '(and (< score default) 
  88. ;               (or (= mark gnus-dormant-mark)
  89. ;                   (= mark gnus-ticked-mark)))
  90. ;             (custom-face-lookup "pink" nil nil nil t nil))
  91. ;           (cons '(or (= mark gnus-dormant-mark)
  92. ;              (= mark gnus-ticked-mark))
  93. ;             (custom-face-lookup "pink" nil nil nil nil nil))
  94.  
  95. ;           (cons '(and (> score default) (= mark gnus-ancient-mark))
  96. ;             (custom-face-lookup "SkyBlue" nil nil t nil nil))
  97. ;           (cons '(and (< score default) (= mark gnus-ancient-mark))
  98. ;             (custom-face-lookup "SkyBlue" nil nil nil t nil))
  99. ;           (cons '(= mark gnus-ancient-mark)
  100. ;             (custom-face-lookup "SkyBlue" nil nil nil nil nil))
  101.  
  102. ;           (cons '(and (> score default) (= mark gnus-unread-mark))
  103. ;             (custom-face-lookup "white" nil nil t nil nil))
  104. ;           (cons '(and (< score default) (= mark gnus-unread-mark))
  105. ;             (custom-face-lookup "white" nil nil nil t nil))
  106. ;           (cons '(= mark gnus-unread-mark)
  107. ;             (custom-face-lookup "white" nil nil nil nil nil))
  108.  
  109. ;           (cons '(> score default) 'bold)
  110. ;           (cons '(< score default) 'italic)))
  111. ;    (t
  112. ;     (list (cons '(= mark gnus-canceled-mark)
  113. ;             (custom-face-lookup "yellow" "black" nil nil nil nil))
  114. ;           (cons '(and (> score default) 
  115. ;               (or (= mark gnus-dormant-mark)
  116. ;                   (= mark gnus-ticked-mark)))
  117. ;             (custom-face-lookup "firebrick" nil nil t nil nil))
  118. ;           (cons '(and (< score default) 
  119. ;               (or (= mark gnus-dormant-mark)
  120. ;                   (= mark gnus-ticked-mark)))
  121. ;             (custom-face-lookup "firebrick" nil nil nil t nil))
  122. ;           (cons '(or (= mark gnus-dormant-mark)
  123. ;              (= mark gnus-ticked-mark))
  124. ;             (custom-face-lookup "firebrick" nil nil nil nil nil))
  125.  
  126. ;           (cons '(and (> score default) (= mark gnus-ancient-mark))
  127. ;             (custom-face-lookup "RoyalBlue" nil nil t nil nil))
  128. ;           (cons '(and (< score default) (= mark gnus-ancient-mark))
  129. ;             (custom-face-lookup "RoyalBlue" nil nil nil t nil))
  130. ;           (cons '(= mark gnus-ancient-mark)
  131. ;             (custom-face-lookup "RoyalBlue" nil nil nil nil nil))
  132.  
  133. ;           (cons '(and (> score default) (/= mark gnus-unread-mark))
  134. ;             (custom-face-lookup "DarkGreen" nil nil t nil nil))
  135. ;           (cons '(and (< score default) (/= mark gnus-unread-mark))
  136. ;             (custom-face-lookup "DarkGreen" nil nil nil t nil))
  137. ;           (cons '(/= mark gnus-unread-mark)
  138. ;             (custom-face-lookup "DarkGreen" nil nil nil nil nil))
  139.  
  140. ;           (cons '(> score default) 'bold)
  141. ;           (cons '(< score default) 'italic))))
  142. ;  "*Alist of `(FORM . FACE)'.
  143. ;Summary lines are highlighted with the FACE for the first FORM which
  144. ;evaluate to a non-nil value.  
  145.  
  146. ;Point will be at the beginning of the line when FORM is evaluated.
  147. ;The following can be used for convenience:
  148.  
  149. ;score:   (gnus-summary-article-score)
  150. ;default: gnus-summary-default-score
  151. ;below:   gnus-summary-mark-below
  152. ;mark:    (gnus-summary-article-mark)
  153.  
  154. ;The latter can be used like this:
  155. ;   ((= mark gnus-replied-mark) . underline)")
  156.  
  157. ;;; article highlights
  158.  
  159. ;see gnus-cus.el
  160. ;(defvar gnus-header-face-alist 
  161. ;  (cond ((not (eq gnus-display-type 'color))
  162. ;     '(("" bold italic)))
  163. ;    ((eq gnus-background-mode 'dark)
  164. ;     (list (list "From" nil 
  165. ;             (custom-face-lookup "SkyBlue" nil nil t t nil))
  166. ;           (list "Subject" nil 
  167. ;             (custom-face-lookup "pink" nil nil t t nil))
  168. ;           (list "Newsgroups:.*," nil
  169. ;             (custom-face-lookup "yellow" nil nil t t nil))
  170. ;           (list "" 
  171. ;             (custom-face-lookup "cyan" nil nil t nil nil)
  172. ;             (custom-face-lookup "green" nil nil nil t nil))))
  173. ;    (t
  174. ;     (list (list "From" nil 
  175. ;             (custom-face-lookup "RoyalBlue" nil nil t t nil))
  176. ;           (list "Subject" nil 
  177. ;             (custom-face-lookup "firebrick" nil nil t t nil))
  178. ;           (list "Newsgroups:.*," nil
  179. ;             (custom-face-lookup "red" nil nil t t nil))
  180. ;           (list ""
  181. ;             (custom-face-lookup "DarkGreen" nil nil t nil nil)
  182. ;             (custom-face-lookup "DarkGreen" nil nil nil t nil)))))
  183. ;  "Alist of headers and faces used for highlighting them.
  184. ;The entries in the list has the form `(REGEXP NAME CONTENT)', where
  185. ;REGEXP is a regular expression matching the beginning of the header,
  186. ;NAME is the face used for highlighting the header name and CONTENT is
  187. ;the face used for highlighting the header content. 
  188.  
  189. ;The first non-nil NAME or CONTENT with a matching REGEXP in the list
  190. ;will be used.")
  191.  
  192.  
  193. ;see gnus-cus.el
  194. ;(defvar gnus-make-foreground t
  195. ;  "Non nil means foreground color to highlight citations.")
  196.  
  197. ;see gnus-cus.el
  198. ;(defvar gnus-article-button-face 'bold
  199. ;  "Face used for text buttons.")
  200.  
  201. ;see gnus-cus.el
  202. ;(defvar gnus-article-mouse-face (if (boundp 'gnus-mouse-face)
  203. ;                    gnus-mouse-face
  204. ;                  'highlight)
  205. ;  "Face used when the mouse is over the button.")
  206.  
  207. ;see gnus-cus.el
  208. ;(defvar gnus-signature-face 'italic
  209. ;  "Face used for signature.")
  210.  
  211. (defvar gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-\\wa-zA-Z0-9_=!?#$@~`%&*+|\\/.,]*[-\\wa-zA-Z0-9_=#$@~`%&*+|\\/]"
  212.   "*Regular expression that matches URLs.")
  213.  
  214. (defvar gnus-button-alist 
  215.   `(("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 
  216.      t gnus-button-message-id 3)
  217.     ("\\(<?\\(url: ?\\)?news:\\([^>\n\t ]*\\)>?\\)" 1 t
  218.      gnus-button-message-id 3)
  219.     ("\\(<URL: *\\)?mailto: *\\([^> \n\t]+\\)>?" 0 t gnus-button-reply 2)
  220.     ;; This is how URLs _should_ be embedded in text...
  221.     ("<URL: *\\([^\n\r>]*\\)>" 0 t gnus-button-url 1)
  222.     ;; Next regexp stolen from highlight-headers.el.
  223.     ;; Modified by Vladimir Alexiev.
  224.     (,gnus-button-url-regexp 0 t gnus-button-url 0))
  225.   "Alist of regexps matching buttons in article bodies.
  226.  
  227. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
  228. REGEXP: is the string matching text around the button,
  229. BUTTON: is the number of the regexp grouping actually matching the button,
  230. FORM: is a lisp expression which must eval to true for the button to
  231. be added, 
  232. CALLBACK: is the function to call when the user push this button, and each
  233. PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
  234.  
  235. CALLBACK can also be a variable, in that case the value of that
  236. variable it the real callback function.")
  237.  
  238. (defvar gnus-header-button-alist 
  239.   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
  240.      0 t gnus-button-message-id 0)
  241.     ("^\\(From\\|Reply-To\\): " ": *\\(.+\\)$" 1 t gnus-button-reply 0)
  242.     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" 
  243.      0 t gnus-button-mailto 0)
  244.     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
  245.     ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
  246.     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
  247.      gnus-button-message-id 3))
  248.   "Alist of headers and regexps to match buttons in article heads.
  249.  
  250. This alist is very similar to `gnus-button-alist', except that each
  251. alist has an additional HEADER element first in each entry:
  252.  
  253. \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
  254.  
  255. HEADER is a regexp to match a header.  For a fuller explanation, see
  256. `gnus-button-alist'.")
  257.  
  258. ;see gnus-cus.el
  259. ;(eval-when-compile
  260. ;  (defvar browse-url-browser-function))
  261.  
  262. ;;; Group mode highlighting.
  263.  
  264. ;see gnus-cus.el
  265. ;(defvar gnus-group-highlight nil
  266. ;  "Group lines are highlighted with the FACE for the first FORM which
  267. ;evaluate to a non-nil value.  
  268. ;
  269. ;Point will be at the beginning of the line when FORM is evaluated.
  270. ;Variables bound when these forms are evaluated include:
  271. ;
  272. ;group: The group name.
  273. ;unread: The number of unread articles.
  274. ;method: The select method.
  275. ;mailp: Whether the select method is a mail method.
  276. ;level: The level of the group.
  277. ;score: The score of the group.
  278. ;ticked: The number of ticked articles in the group.
  279. ;")
  280.  
  281.  
  282. ;;; Internal variables.
  283.  
  284. (defvar gnus-button-marker-list nil)
  285.  
  286.  
  287.  
  288. (eval-and-compile
  289.   (autoload 'nnkiboze-generate-groups "nnkiboze")
  290.   (autoload 'gnus-cite-parse-maybe "gnus-cite" nil t))
  291.  
  292. ;;;
  293. ;;; gnus-menu
  294. ;;;
  295.  
  296. (defun gnus-visual-turn-off-edit-menu (type)
  297.   (define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
  298.     [menu-bar edit] 'undefined))
  299.  
  300. ;; Newsgroup buffer
  301.  
  302. (defun gnus-group-make-menu-bar ()
  303.   (gnus-visual-turn-off-edit-menu 'group)
  304.   (or 
  305.    (boundp 'gnus-group-reading-menu)
  306.    (progn
  307.      (easy-menu-define
  308.       gnus-group-reading-menu gnus-group-mode-map ""
  309.       '("Group"
  310.     ["Read" gnus-group-read-group (gnus-group-group-name)]
  311.     ["Select" gnus-group-select-group (gnus-group-group-name)]
  312.     ["See old articles" (gnus-group-select-group 'all)
  313.      :keys "C-u SPC" :active (gnus-group-group-name)]
  314.     ["Catch up" gnus-group-catchup-current (gnus-group-group-name)]
  315.     ["Catch up all articles" gnus-group-catchup-current-all
  316.      (gnus-group-group-name)]
  317.     ["Check for new articles" gnus-group-get-new-news-this-group
  318.      (gnus-group-group-name)]
  319.     ["Toggle subscription" gnus-group-unsubscribe-current-group
  320.      (gnus-group-group-name)]
  321.     ["Kill" gnus-group-kill-group (gnus-group-group-name)]
  322.     ["Yank" gnus-group-yank-group gnus-list-of-killed-groups]
  323.     ["Describe" gnus-group-describe-group (gnus-group-group-name)]
  324.     ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)]
  325.     ["Edit kill file" gnus-group-edit-local-kill
  326.      (gnus-group-group-name)]
  327.     ;; Actually one should check, if any of the marked groups gives t for
  328.     ;; (gnus-check-backend-function 'request-expire-articles ...)
  329.     ["Expire articles" gnus-group-expire-articles
  330.      (or (and (gnus-group-group-name)
  331.           (gnus-check-backend-function
  332.            'request-expire-articles
  333.            (gnus-group-group-name))) gnus-group-marked)]
  334.     ["Set group level" gnus-group-set-current-level
  335.      (gnus-group-group-name)]
  336.     ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)]
  337.     ))
  338.   
  339.      (easy-menu-define
  340.       gnus-group-group-menu gnus-group-mode-map ""
  341.       '("Groups"
  342.     ("Listing"
  343.      ["List unread subscribed groups" gnus-group-list-groups t]
  344.      ["List (un)subscribed groups" gnus-group-list-all-groups t]
  345.      ["List killed groups" gnus-group-list-killed gnus-killed-list]
  346.      ["List zombie groups" gnus-group-list-zombies gnus-zombie-list]
  347.      ["List level..." gnus-group-list-level t]
  348.      ["Describe all groups" gnus-group-describe-all-groups t]
  349.      ["Group apropos..." gnus-group-apropos t]
  350.      ["Group and description apropos..." gnus-group-description-apropos t]
  351.      ["List groups matching..." gnus-group-list-matching t]
  352.      ["List all groups matching..." gnus-group-list-all-matching t]
  353.      ["List active file" gnus-group-list-active t])
  354.     ("Sort"
  355.      ["Default sort" gnus-group-sort-groups
  356.       (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
  357.      ["Sort by method" gnus-group-sort-groups-by-method
  358.       (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
  359.      ["Sort by rank" gnus-group-sort-groups-by-rank
  360.       (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
  361.      ["Sort by score" gnus-group-sort-groups-by-score
  362.       (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
  363.      ["Sort by level" gnus-group-sort-groups-by-level
  364.       (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
  365.      ["Sort by unread" gnus-group-sort-groups-by-unread
  366.       (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
  367.      ["Sort by name" gnus-group-sort-groups-by-alphabet
  368.       (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))])
  369.     ("Mark"
  370.      ["Mark group" gnus-group-mark-group
  371.       (and (gnus-group-group-name)
  372.            (not (memq (gnus-group-group-name) gnus-group-marked)))]
  373.      ["Unmark group" gnus-group-unmark-group
  374.       (and (gnus-group-group-name)
  375.            (memq (gnus-group-group-name) gnus-group-marked))]
  376.      ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked]
  377.      ["Mark regexp..." gnus-group-mark-regexp t]
  378.      ["Mark region" gnus-group-mark-region t]
  379.      ["Mark buffer" gnus-group-mark-buffer t]
  380.      ["Execute command" gnus-group-universal-argument
  381.       (or gnus-group-marked (gnus-group-group-name))])
  382.     ("Subscribe"
  383.      ["Subscribe to random group" gnus-group-unsubscribe-group t]
  384.      ["Kill all newsgroups in region" gnus-group-kill-region t]
  385.      ["Kill all zombie groups" gnus-group-kill-all-zombies
  386.       gnus-zombie-list]
  387.      ["Kill all groups on level..." gnus-group-kill-level t])
  388.     ("Foreign groups"
  389.      ["Make a foreign group" gnus-group-make-group t]
  390.      ["Add a directory group" gnus-group-make-directory-group t]
  391.      ["Add the help group" gnus-group-make-help-group t]
  392.      ["Add the archive group" gnus-group-make-archive-group t]
  393.      ["Make a doc group" gnus-group-make-doc-group t]
  394.      ["Make a kiboze group" gnus-group-make-kiboze-group t]
  395.      ["Make a virtual group" gnus-group-make-empty-virtual t]
  396.      ["Add a group to a virtual" gnus-group-add-to-virtual t]
  397.      ["Rename group" gnus-group-rename-group
  398.       (gnus-check-backend-function
  399.        'request-rename-group (gnus-group-group-name))]
  400.      ["Delete group" gnus-group-delete-group
  401.       (gnus-check-backend-function
  402.        'request-delete-group (gnus-group-group-name))])
  403.     ("Editing groups"
  404.      ["Parameters" gnus-group-edit-group-parameters
  405.       (gnus-group-group-name)]
  406.      ["Select method" gnus-group-edit-group-method
  407.       (gnus-group-group-name)]
  408.      ["Info" gnus-group-edit-group (gnus-group-group-name)])
  409.     ("Score file"
  410.      ["Flush cache" gnus-score-flush-cache
  411.       (or gnus-score-cache gnus-short-name-score-file-cache)])
  412.     ("Move"
  413.      ["Next" gnus-group-next-group t]
  414.      ["Previous" gnus-group-prev-group t]
  415.      ["Next unread" gnus-group-next-unread-group t]
  416.      ["Previous unread" gnus-group-prev-unread-group t]
  417.      ["Next unread same level" gnus-group-next-unread-group-same-level t]
  418.      ["Previous unread same level"
  419.       gnus-group-previous-unread-group-same-level t]
  420.      ["Jump to group" gnus-group-jump-to-group t]
  421.      ["First unread group" gnus-group-first-unread-group t]
  422.      ["Best unread group" gnus-group-best-unread-group t])
  423.     ["Transpose" gnus-group-transpose-groups
  424.      (gnus-group-group-name)]
  425.     ["Read a directory as a group..." gnus-group-enter-directory t]
  426.     ))
  427.  
  428.      (easy-menu-define
  429.       gnus-group-misc-menu gnus-group-mode-map ""
  430.       '("Misc"
  431.     ["Send a bug report" gnus-bug t]
  432.     ["Send a mail" gnus-group-mail t]
  433.     ["Post an article..." gnus-group-post-news t]
  434.     ["Customize score file" gnus-score-customize t]
  435.     ["Check for new news" gnus-group-get-new-news t]     
  436.     ["Activate all groups" gnus-activate-all-groups t]
  437.     ["Delete bogus groups" gnus-group-check-bogus-groups t]
  438.     ["Find new newsgroups" gnus-find-new-newsgroups t]
  439.     ["Restart Gnus" gnus-group-restart t]
  440.     ["Read init file" gnus-group-read-init-file t]
  441.     ["Browse foreign server" gnus-group-browse-foreign-server t]
  442.     ["Enter server buffer" gnus-group-enter-server-mode t]
  443.     ["Expire all expirable articles" gnus-group-expire-all-groups t]
  444.     ["Generate any kiboze groups" nnkiboze-generate-groups t]
  445.     ["Gnus version" gnus-version t]
  446.     ["Save .newsrc files" gnus-group-save-newsrc t]
  447.     ["Suspend Gnus" gnus-group-suspend t]
  448.     ["Clear dribble buffer" gnus-group-clear-dribble t]
  449.     ["Exit from Gnus" gnus-group-exit t]
  450.     ["Exit without saving" gnus-group-quit t]
  451.     ["Edit global kill file" gnus-group-edit-global-kill t]
  452.     ["Read manual" gnus-info-find-node t]
  453.     ["Toggle topics" gnus-topic-mode t]
  454.     ("SOUP"
  455.      ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)]
  456.      ["Send replies" gnus-soup-send-replies
  457.       (fboundp 'gnus-soup-pack-packet)]
  458.      ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)]
  459.      ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)]
  460.      ["Brew SOUP" gnus-soup-brew-soup (fboundp 'gnus-soup-pack-packet)])
  461.     ))
  462.      (run-hooks 'gnus-group-menu-hook)
  463.      )))
  464.  
  465. ;; Summary buffer
  466. (defun gnus-summary-make-menu-bar ()
  467.   (gnus-visual-turn-off-edit-menu 'summary)
  468.  
  469.   (unless (boundp 'gnus-summary-misc-menu)
  470.  
  471.     (easy-menu-define
  472.      gnus-summary-misc-menu gnus-summary-mode-map ""
  473.      '("Misc"
  474.        ("Mark"
  475.     ("Read"
  476.      ["Mark as read" gnus-summary-mark-as-read-forward t]
  477.      ["Mark same subject and select"
  478.       gnus-summary-kill-same-subject-and-select t]
  479.      ["Mark same subject" gnus-summary-kill-same-subject t]
  480.      ["Catchup" gnus-summary-catchup t]
  481.      ["Catchup all" gnus-summary-catchup-all t]
  482.      ["Catchup to here" gnus-summary-catchup-to-here t]
  483.      ["Catchup region" gnus-summary-mark-region-as-read t]
  484.      ["Mark excluded" gnus-summary-limit-mark-excluded-as-read t])
  485.     ("Various"
  486.      ["Tick" gnus-summary-tick-article-forward t]
  487.      ["Mark as dormant" gnus-summary-mark-as-dormant t]
  488.      ["Remove marks" gnus-summary-clear-mark-forward t]
  489.      ["Set expirable mark" gnus-summary-mark-as-expirable t]
  490.      ["Set bookmark" gnus-summary-set-bookmark t]
  491.      ["Remove bookmark" gnus-summary-remove-bookmark t])
  492.     ("Limit"
  493.      ["Marks..." gnus-summary-limit-to-marks t]
  494.      ["Subject..." gnus-summary-limit-to-subject t]
  495.      ["Author..." gnus-summary-limit-to-author t]
  496.      ["Score" gnus-summary-limit-to-score t]
  497.      ["Unread" gnus-summary-limit-to-unread t]
  498.      ["Non-dormant" gnus-summary-limit-exclude-dormant t]
  499.      ["Articles" gnus-summary-limit-to-articles t]
  500.      ["Pop limit" gnus-summary-pop-limit t]
  501.      ["Show dormant" gnus-summary-limit-include-dormant t]
  502.      ["Hide childless dormant" 
  503.       gnus-summary-limit-exclude-childless-dormant t]
  504.      ;;["Hide thread" gnus-summary-limit-exclude-thread t]
  505.      ["Show expunged" gnus-summary-show-all-expunged t])
  506.     ("Process mark"
  507.      ["Set mark" gnus-summary-mark-as-processable t]
  508.      ["Remove mark" gnus-summary-unmark-as-processable t]
  509.      ["Remove all marks" gnus-summary-unmark-all-processable t]
  510.      ["Mark above" gnus-uu-mark-over t]
  511.      ["Mark series" gnus-uu-mark-series t]
  512.      ["Mark region" gnus-uu-mark-region t]
  513.      ["Mark by regexp..." gnus-uu-mark-by-regexp t]
  514.      ["Mark all" gnus-uu-mark-all t]
  515.      ["Mark buffer" gnus-uu-mark-buffer t]
  516.      ["Mark sparse" gnus-uu-mark-sparse t]
  517.      ["Mark thread" gnus-uu-mark-thread t]
  518.      ["Unmark thread" gnus-uu-unmark-thread t]))
  519.        ("Scroll article"
  520.     ["Page forward" gnus-summary-next-page t]
  521.     ["Page backward" gnus-summary-prev-page t]
  522.     ["Line forward" gnus-summary-scroll-up t])
  523.        ("Move"
  524.     ["Next unread article" gnus-summary-next-unread-article t]
  525.     ["Previous unread article" gnus-summary-prev-unread-article t]
  526.     ["Next article" gnus-summary-next-article t]
  527.     ["Previous article" gnus-summary-prev-article t]
  528.     ["Next unread subject" gnus-summary-next-unread-subject t]
  529.     ["Previous unread subject" gnus-summary-prev-unread-subject t]
  530.     ["Next article same subject" gnus-summary-next-same-subject t]
  531.     ["Previous article same subject" gnus-summary-prev-same-subject t]
  532.     ["First unread article" gnus-summary-first-unread-article t]
  533.     ["Best unread article" gnus-summary-best-unread-article t]
  534.     ["Go to subject number..." gnus-summary-goto-subject t]
  535.     ["Go to article number..." gnus-summary-goto-article t]
  536.     ["Go to the last article" gnus-summary-goto-last-article t]
  537.     ["Pop article off history" gnus-summary-pop-article t])    
  538.        ("Sort"
  539.     ["Sort by number" gnus-summary-sort-by-number t]
  540.     ["Sort by author" gnus-summary-sort-by-author t]
  541.     ["Sort by subject" gnus-summary-sort-by-subject t]
  542.     ["Sort by date" gnus-summary-sort-by-date t]
  543.     ["Sort by score" gnus-summary-sort-by-score t])
  544.        ("Exit"
  545.     ["Catchup and exit" gnus-summary-catchup-and-exit t]
  546.     ["Catchup all and exit" gnus-summary-catchup-and-exit t]
  547.     ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t]
  548.     ["Exit group" gnus-summary-exit t]
  549.     ["Exit group without updating" gnus-summary-exit-no-update t]
  550.     ["Exit and goto next group" gnus-summary-next-group t]
  551.     ["Exit and goto prev group" gnus-summary-prev-group t]
  552.     ["Reselect group" gnus-summary-reselect-current-group t]
  553.     ["Rescan group" gnus-summary-rescan-group t])
  554.        ("Help"
  555.     ["Fetch group FAQ" gnus-summary-fetch-faq t]
  556.     ["Describe group" gnus-summary-describe-group t]
  557.     ["Read manual" gnus-info-find-node t])
  558.        ("Cache"
  559.     ["Enter article" gnus-cache-enter-article t]
  560.     ["Remove article" gnus-cache-remove-article t])
  561.        ("Modes"
  562.     ["Pick and read" gnus-pick-mode t]
  563.     ["Binary" gnus-binary-mode t])
  564.        ["Filter articles..." gnus-summary-execute-command t]
  565.        ["Run command on subjects..." gnus-summary-universal-argument t]
  566.        ["Toggle line truncation" gnus-summary-toggle-truncation t]
  567.        ["Expand window" gnus-summary-expand-window t]
  568.        ["Expire expirable articles" gnus-summary-expire-articles
  569.     (gnus-check-backend-function
  570.      'request-expire-articles gnus-newsgroup-name)]
  571.        ["Edit local kill file" gnus-summary-edit-local-kill t]
  572.        ["Edit main kill file" gnus-summary-edit-global-kill t]
  573.        ))
  574.  
  575.     (easy-menu-define
  576.      gnus-summary-kill-menu gnus-summary-mode-map ""
  577.      (cons
  578.       "Score"
  579.       (nconc
  580.        (list
  581.     ["Enter score..." gnus-summary-score-entry t])
  582.        (gnus-visual-score-map 'increase)
  583.        (gnus-visual-score-map 'lower)
  584.        '(("Mark"
  585.       ["Kill below" gnus-summary-kill-below t]
  586.       ["Mark above" gnus-summary-mark-above t]
  587.       ["Tick above" gnus-summary-tick-above t]
  588.       ["Clear above" gnus-summary-clear-above t])
  589.      ["Current score" gnus-summary-current-score t]
  590.      ["Set score" gnus-summary-set-score t]
  591.      ["Customize score file" gnus-score-customize t]
  592.      ["Switch current score file..." gnus-score-change-score-file t]
  593.      ["Set mark below..." gnus-score-set-mark-below t]
  594.      ["Set expunge below..." gnus-score-set-expunge-below t]
  595.      ["Edit current score file" gnus-score-edit-current-scores t]
  596.      ["Edit score file" gnus-score-edit-file t]
  597.      ["Trace score" gnus-score-find-trace t]
  598.      ["Rescore buffer" gnus-summary-rescore t]
  599.      ["Increase score..." gnus-summary-increase-score t]
  600.      ["Lower score..." gnus-summary-lower-score t]))))
  601.  
  602.     '(("Default header"
  603.        ["Ask" (gnus-score-set-default 'gnus-score-default-header nil)
  604.     :style radio 
  605.     :selected (null gnus-score-default-header)]
  606.        ["From" (gnus-score-set-default 'gnus-score-default-header 'a)
  607.     :style radio 
  608.     :selected (eq gnus-score-default-header 'a)]
  609.        ["Subject" (gnus-score-set-default 'gnus-score-default-header 's)
  610.     :style radio 
  611.     :selected (eq gnus-score-default-header 's)]
  612.        ["Article body"
  613.     (gnus-score-set-default 'gnus-score-default-header 'b)
  614.     :style radio 
  615.     :selected (eq gnus-score-default-header 'b )]
  616.        ["All headers"
  617.     (gnus-score-set-default 'gnus-score-default-header 'h)
  618.     :style radio 
  619.     :selected (eq gnus-score-default-header 'h )]
  620.        ["Message-Id" (gnus-score-set-default 'gnus-score-default-header 'i)
  621.     :style radio 
  622.     :selected (eq gnus-score-default-header 'i )]
  623.        ["Thread" (gnus-score-set-default 'gnus-score-default-header 't)
  624.     :style radio 
  625.     :selected (eq gnus-score-default-header 't )]
  626.        ["Crossposting"
  627.     (gnus-score-set-default 'gnus-score-default-header 'x)
  628.     :style radio 
  629.     :selected (eq gnus-score-default-header 'x )]
  630.        ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l)
  631.     :style radio 
  632.     :selected (eq gnus-score-default-header 'l )]
  633.        ["Date" (gnus-score-set-default 'gnus-score-default-header 'd)
  634.     :style radio 
  635.     :selected (eq gnus-score-default-header 'd )]
  636.        ["Followups to author"
  637.     (gnus-score-set-default 'gnus-score-default-header 'f)
  638.     :style radio 
  639.     :selected (eq gnus-score-default-header 'f )])
  640.       ("Default type"
  641.        ["Ask" (gnus-score-set-default 'gnus-score-default-type nil)
  642.     :style radio 
  643.     :selected (null gnus-score-default-type)]
  644.        ;; The `:active' key is commented out in the following,
  645.        ;; because the GNU Emacs hack to support radio buttons use
  646.        ;; active to indicate which button is selected.  
  647.        ["Substring" (gnus-score-set-default 'gnus-score-default-type 's)
  648.     :style radio 
  649.     ;; :active (not (memq gnus-score-default-header '(l d)))
  650.     :selected (eq gnus-score-default-type 's)]
  651.        ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r)
  652.     :style radio
  653.     ;; :active (not (memq gnus-score-default-header '(l d)))
  654.     :selected (eq gnus-score-default-type 'r)]
  655.        ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e)
  656.     :style radio
  657.     ;; :active (not (memq gnus-score-default-header '(l d)))
  658.     :selected (eq gnus-score-default-type 'e)]
  659.        ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f)
  660.     :style radio 
  661.     ;; :active (not (memq gnus-score-default-header '(l d)))
  662.     :selected (eq gnus-score-default-type 'f)]
  663.        ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b)
  664.     :style radio 
  665.     ;; :active (eq (gnus-score-default-header 'd))
  666.     :selected (eq gnus-score-default-type 'b)]
  667.        ["At date" (gnus-score-set-default 'gnus-score-default-type 'n)
  668.     :style radio 
  669.     ;; :active (eq (gnus-score-default-header 'd))
  670.     :selected (eq gnus-score-default-type 'n)]
  671.        ["After date" (gnus-score-set-default 'gnus-score-default-type 'a)
  672.     :style radio 
  673.     ;; :active (eq (gnus-score-default-header 'd))
  674.     :selected (eq gnus-score-default-type 'a)]
  675.        ["Less than number"
  676.     (gnus-score-set-default 'gnus-score-default-type '<)
  677.     :style radio 
  678.     ;; :active (eq (gnus-score-default-header 'l))
  679.     :selected (eq gnus-score-default-type '<)]
  680.        ["Equal to number"
  681.     (gnus-score-set-default 'gnus-score-default-type '=)
  682.     :style radio 
  683.     ;; :active (eq (gnus-score-default-header 'l))
  684.     :selected (eq gnus-score-default-type '=)]
  685.        ["Greater than number" 
  686.     (gnus-score-set-default 'gnus-score-default-type '>)
  687.     :style radio 
  688.     ;; :active (eq (gnus-score-default-header 'l))
  689.     :selected (eq gnus-score-default-type '>)])
  690.       ["Default fold" gnus-score-default-fold-toggle
  691.        :style toggle
  692.        :selected gnus-score-default-fold]
  693.       ("Default duration"
  694.        ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil)
  695.     :style radio
  696.     :selected (null gnus-score-default-duration)]
  697.        ["Permanent"
  698.     (gnus-score-set-default 'gnus-score-default-duration 'p)
  699.     :style radio
  700.     :selected (eq gnus-score-default-duration 'p)]
  701.        ["Temporary"
  702.     (gnus-score-set-default 'gnus-score-default-duration 't)
  703.     :style radio
  704.     :selected (eq gnus-score-default-duration 't)]
  705.        ["Immediate" 
  706.     (gnus-score-set-default 'gnus-score-default-duration 'i)
  707.     :style radio
  708.     :selected (eq gnus-score-default-duration 'i)]))
  709.  
  710.     (easy-menu-define
  711.      gnus-summary-article-menu gnus-summary-mode-map ""
  712.      '("Article"
  713.        ("Hide"
  714.     ["All" gnus-article-hide t]
  715.     ["Headers" gnus-article-hide-headers t]
  716.     ["Signature" gnus-article-hide-signature t]
  717.     ["Citation" gnus-article-hide-citation t]
  718.     ["PGP" gnus-article-hide-pgp t]
  719.     ["Boring headers" gnus-article-hide-boring-headers t])
  720.        ("Highlight"
  721.     ["All" gnus-article-highlight t]
  722.     ["Headers" gnus-article-highlight-headers t]
  723.     ["Signature" gnus-article-highlight-signature t]
  724.     ["Citation" gnus-article-highlight-citation t])
  725.        ("Date"
  726.     ["Local" gnus-article-date-local t]
  727.     ["UT" gnus-article-date-ut t]
  728.     ["Original" gnus-article-date-original t]
  729.     ["Lapsed" gnus-article-date-lapsed t])
  730.        ("Filter"
  731.     ["Overstrike" gnus-article-treat-overstrike t]
  732.     ["Word wrap" gnus-article-fill-cited-article t]
  733.     ["CR" gnus-article-remove-cr t]
  734.     ["Trailing blank lines" gnus-article-remove-trailing-blank-lines t]
  735.     ["Show X-Face" gnus-article-display-x-face t]
  736.     ["Quoted-Printable" gnus-article-de-quoted-unreadable t]
  737.     ["Rot 13" gnus-summary-caesar-message t]
  738.     ["Add buttons" gnus-article-add-buttons t]
  739.     ["Add buttons to head" gnus-article-add-buttons-to-head t]
  740.     ["Stop page breaking" gnus-summary-stop-page-breaking t]
  741.     ["Toggle MIME" gnus-summary-toggle-mime t]
  742.     ["Verbose header" gnus-summary-verbose-headers t]
  743.     ["Toggle header" gnus-summary-toggle-header t])
  744.        ("Output"
  745.     ["Save in default format" gnus-summary-save-article t]
  746.     ["Save in file" gnus-summary-save-article-file t]
  747.     ["Save in Unix mail format" gnus-summary-save-article-mail t]
  748.     ["Save in MH folder" gnus-summary-save-article-folder t]
  749.     ["Save in VM folder" gnus-summary-save-article-vm t]
  750.     ["Save in RMAIL mbox" gnus-summary-save-article-rmail t]
  751.     ["Save body in file" gnus-summary-save-article-body-file t]
  752.     ["Pipe through a filter" gnus-summary-pipe-output t]
  753.     ["Add to SOUP packet" gnus-soup-add-article t])
  754.        ("Backend"
  755.     ["Respool article..." gnus-summary-respool-article t]
  756.     ["Move article..." gnus-summary-move-article
  757.      (gnus-check-backend-function
  758.       'request-move-article gnus-newsgroup-name)]
  759.     ["Copy article..." gnus-summary-copy-article t]
  760.     ["Crosspost article..." gnus-summary-crosspost-article
  761.      (gnus-check-backend-function
  762.       'request-replace-article gnus-newsgroup-name)]
  763.     ["Import file..." gnus-summary-import-article t]
  764.     ["Edit article" gnus-summary-edit-article
  765.      (not (gnus-group-read-only-p))]
  766.     ["Delete article" gnus-summary-delete-article
  767.      (gnus-check-backend-function
  768.       'request-expire-articles gnus-newsgroup-name)]
  769.     ["Query respool" gnus-summary-respool-query t]
  770.     ["Delete expirable articles" gnus-summary-expire-articles-now
  771.      (gnus-check-backend-function
  772.       'request-expire-articles gnus-newsgroup-name)])
  773.        ("Extract"
  774.     ["Uudecode" gnus-uu-decode-uu t]
  775.     ["Uudecode and save" gnus-uu-decode-uu-and-save t]
  776.     ["Unshar" gnus-uu-decode-unshar t]
  777.     ["Unshar and save" gnus-uu-decode-unshar-and-save t]
  778.     ["Save" gnus-uu-decode-save t]
  779.     ["Binhex" gnus-uu-decode-binhex t]
  780.     ["Postscript" gnus-uu-decode-postscript t])
  781.        ["Enter digest buffer" gnus-summary-enter-digest-group t]
  782.        ["Isearch article..." gnus-summary-isearch-article t]
  783.        ["Search articles forward..." gnus-summary-search-article-forward t]
  784.        ["Search articles backward..." gnus-summary-search-article-backward t]
  785.        ["Beginning of the article" gnus-summary-beginning-of-article t]
  786.        ["End of the article" gnus-summary-end-of-article t]
  787.        ["Fetch parent of article" gnus-summary-refer-parent-article t]
  788.        ["Fetch referenced articles" gnus-summary-refer-references t]
  789.        ["Fetch article with id..." gnus-summary-refer-article t]
  790.        ["Redisplay" gnus-summary-show-article t]))
  791.  
  792.     (easy-menu-define
  793.      gnus-summary-thread-menu gnus-summary-mode-map ""
  794.      '("Threads"
  795.        ["Toggle threading" gnus-summary-toggle-threads t]
  796.        ["Hide threads" gnus-summary-hide-all-threads t]
  797.        ["Show threads" gnus-summary-show-all-threads t]
  798.        ["Hide thread" gnus-summary-hide-thread t]
  799.        ["Show thread" gnus-summary-show-thread t]
  800.        ["Go to next thread" gnus-summary-next-thread t]
  801.        ["Go to previous thread" gnus-summary-prev-thread t]
  802.        ["Go down thread" gnus-summary-down-thread t]
  803.        ["Go up thread" gnus-summary-up-thread t]
  804.        ["Top of thread" gnus-summary-top-thread t]
  805.        ["Mark thread as read" gnus-summary-kill-thread t]
  806.        ["Lower thread score" gnus-summary-lower-thread t]
  807.        ["Raise thread score" gnus-summary-raise-thread t]
  808.        ["Rethread current" gnus-summary-rethread-current t]
  809.        ))
  810.  
  811.     (easy-menu-define
  812.      gnus-summary-post-menu gnus-summary-mode-map ""
  813.      '("Post"
  814.        ["Post an article" gnus-summary-post-news t]
  815.        ["Followup" gnus-summary-followup t]
  816.        ["Followup and yank" gnus-summary-followup-with-original t]
  817.        ["Supersede article" gnus-summary-supersede-article t]
  818.        ["Cancel article" gnus-summary-cancel-article t]
  819.        ["Reply" gnus-summary-reply t]
  820.        ["Reply and yank" gnus-summary-reply-with-original t]
  821.        ["Mail forward" gnus-summary-mail-forward t]
  822.        ["Post forward" gnus-summary-post-forward t]
  823.        ["Digest and mail" gnus-uu-digest-mail-forward t]
  824.        ["Digest and post" gnus-uu-digest-post-forward t]
  825.        ["Resend message" gnus-summary-resend-message t]
  826.        ["Send bounced mail" gnus-summary-resend-bounced-mail t]
  827.        ["Send a mail" gnus-summary-mail-other-window t]
  828.        ["Uuencode and post" gnus-uu-post-news t]
  829.        ;;("Draft"
  830.        ;;["Send" gnus-summary-send-draft t]
  831.        ;;["Send bounced" gnus-resend-bounced-mail t])
  832.        ))
  833.     (run-hooks 'gnus-summary-menu-hook)
  834.     ))
  835.  
  836. (defun gnus-score-set-default (var value)
  837.   "A version of set that updates the GNU Emacs menu-bar."
  838.   (set var value)
  839.   ;; It is the message that forces the active status to be updated.
  840.   (message ""))
  841.  
  842. (defun gnus-visual-score-map (type)
  843.   (if t
  844.       nil
  845.     (let ((headers '(("author" "from" string)
  846.              ("subject" "subject" string)
  847.              ("article body" "body" string)
  848.              ("article head" "head" string)
  849.              ("xref" "xref" string)
  850.              ("lines" "lines" number)
  851.              ("followups to author" "followup" string)))
  852.       (types '((number ("less than" <)
  853.                ("greater than" >)
  854.                ("equal" =))
  855.            (string ("substring" s)
  856.                ("exact string" e)
  857.                ("fuzzy string" f)
  858.                ("regexp" r))))
  859.       (perms '(("temporary" (current-time-string))
  860.            ("permanent" nil)
  861.            ("immediate" now)))
  862.       header)
  863.       (list 
  864.        (apply 
  865.     'nconc
  866.     (list
  867.      (if (eq type 'lower)
  868.          "Lower score"
  869.        "Increase score"))
  870.     (let (outh)
  871.       (while headers
  872.         (setq header (car headers))
  873.         (setq outh 
  874.           (cons 
  875.            (apply 
  876.             'nconc
  877.             (list (car header))
  878.             (let ((ts (cdr (assoc (nth 2 header) types)))
  879.               outt)
  880.               (while ts
  881.             (setq outt
  882.                   (cons 
  883.                    (apply 
  884.                 'nconc
  885.                 (list (caar ts))
  886.                 (let ((ps perms)
  887.                       outp)
  888.                   (while ps
  889.                     (setq outp
  890.                       (cons
  891.                        (vector
  892.                         (caar ps) 
  893.                         (list
  894.                          'gnus-summary-score-entry
  895.                          (nth 1 header)
  896.                          (if (or (string= (nth 1 header) 
  897.                                   "head")
  898.                              (string= (nth 1 header)
  899.                                   "body"))
  900.                          ""
  901.                            (list 'gnus-summary-header 
  902.                              (nth 1 header)))
  903.                          (list 'quote (nth 1 (car ts)))
  904.                          (list 'gnus-score-default nil)
  905.                          (nth 1 (car ps))
  906.                          t)
  907.                         t)
  908.                        outp))
  909.                     (setq ps (cdr ps)))
  910.                   (list (nreverse outp))))
  911.                    outt))
  912.             (setq ts (cdr ts)))
  913.               (list (nreverse outt))))
  914.            outh))
  915.         (setq headers (cdr headers)))
  916.       (list (nreverse outh))))))))
  917.  
  918. ;; Article buffer
  919. (defun gnus-article-make-menu-bar ()
  920.   (gnus-visual-turn-off-edit-menu 'summary)
  921.   (or
  922.    (boundp 'gnus-article-article-menu)
  923.    (progn
  924.      (easy-menu-define
  925.       gnus-article-article-menu gnus-article-mode-map ""
  926.       '("Article"
  927.     ["Scroll forwards" gnus-article-goto-next-page t]
  928.     ["Scroll backwards" gnus-article-goto-prev-page t]
  929.     ["Show summary" gnus-article-show-summary t]
  930.     ["Fetch Message-ID at point" gnus-article-refer-article t]
  931.     ["Mail to address at point" gnus-article-mail t]
  932.     ))
  933.  
  934.      (easy-menu-define
  935.       gnus-article-treatment-menu gnus-article-mode-map ""
  936.       '("Treatment"
  937.     ["Hide headers" gnus-article-hide-headers t]
  938.     ["Hide signature" gnus-article-hide-signature t]
  939.     ["Hide citation" gnus-article-hide-citation t]
  940.     ["Treat overstrike" gnus-article-treat-overstrike t]
  941.     ["Remove carriage return" gnus-article-remove-cr t]
  942.     ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
  943.     ))
  944.      (run-hooks 'gnus-article-menu-hook))))
  945.  
  946. ;;;
  947. ;;; summary highlights
  948. ;;;
  949.  
  950. (defun gnus-highlight-selected-summary ()
  951.   ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
  952.   ;; Highlight selected article in summary buffer
  953.   (if gnus-summary-selected-face
  954.       (save-excursion
  955.     (let* ((beg (progn (beginning-of-line) (point)))
  956.            (end (progn (end-of-line) (point)))
  957.            ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>.
  958.            (from (if (get-text-property beg gnus-mouse-face-prop) 
  959.              beg
  960.                (1+ (or (next-single-property-change 
  961.                 beg gnus-mouse-face-prop nil end) 
  962.                    beg))))
  963.            (to (1- (or (next-single-property-change
  964.                 from gnus-mouse-face-prop nil end)
  965.                end))))
  966.       ;; If no mouse-face prop on line (e.g. xemacs) we 
  967.       ;; will have to = from = end, so we highlight the
  968.       ;; entire line instead.
  969.       (if (= (+ to 2) from)
  970.           (progn
  971.         (setq from beg)
  972.         (setq to end)))
  973.       (if gnus-newsgroup-selected-overlay
  974.           (gnus-move-overlay gnus-newsgroup-selected-overlay 
  975.                  from to (current-buffer))
  976.         (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to))
  977.         (gnus-overlay-put gnus-newsgroup-selected-overlay 'face 
  978.                   gnus-summary-selected-face))))))
  979.  
  980. ;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>.
  981. (defun gnus-summary-highlight-line ()
  982.   "Highlight current line according to `gnus-summary-highlight'."
  983.   (let* ((list gnus-summary-highlight)
  984.      (p (point))
  985.      (end (progn (end-of-line) (point)))
  986.      ;; now find out where the line starts and leave point there.
  987.      (beg (progn (beginning-of-line) (point)))
  988.      (article (gnus-summary-article-number))
  989.      (score (or (cdr (assq (or article gnus-current-article)
  990.                    gnus-newsgroup-scored))
  991.             gnus-summary-default-score 0))
  992.      (mark (or (gnus-summary-article-mark) gnus-unread-mark))
  993.      (inhibit-read-only t))
  994.     ;; Eval the cars of the lists until we find a match.
  995.     (let ((default gnus-summary-default-score))
  996.       (while (and list
  997.           (not (eval (caar list))))
  998.     (setq list (cdr list))))
  999.     (let ((face (cdar list)))
  1000.       (unless (eq face (get-text-property beg 'face))
  1001.     (gnus-put-text-property 
  1002.      beg end 'face 
  1003.      (setq face (if (boundp face) (symbol-value face) face)))
  1004.     (when gnus-summary-highlight-line-function
  1005.       (funcall gnus-summary-highlight-line-function article face))))
  1006.     (goto-char p)))
  1007.  
  1008. (defun gnus-group-highlight-line ()
  1009.   "Highlight the current line according to `gnus-group-highlight'."
  1010.   (let* ((list gnus-group-highlight)
  1011.      (p (point))
  1012.      (end (progn (end-of-line) (point)))
  1013.      ;; now find out where the line starts and leave point there.
  1014.      (beg (progn (beginning-of-line) (point)))
  1015.      (group (gnus-group-group-name))
  1016.      (entry (gnus-group-entry group))
  1017.      (unread (if (numberp (car entry)) (car entry) 0))
  1018.      (info (nth 2 entry))
  1019.      (method (gnus-server-get-method group (gnus-info-method info)))
  1020.      (marked (gnus-info-marks info))
  1021.      (mailp (memq 'mail (assoc (symbol-name
  1022.                     (car (or method gnus-select-method)))
  1023.                    gnus-valid-select-methods)))
  1024.      (level (or (gnus-info-level info) 9))
  1025.      (score (or (gnus-info-score info) 0))
  1026.      (ticked (gnus-range-length (cdr (assq 'tick marked))))
  1027.      (inhibit-read-only t))
  1028.     ;; Eval the cars of the lists until we find a match.
  1029.     (while (and list
  1030.         (not (eval (caar list))))
  1031.       (setq list (cdr list)))
  1032.     (let ((face (cdar list)))
  1033.       (unless (eq face (get-text-property beg 'face))
  1034.     (gnus-put-text-property 
  1035.      beg end 'face 
  1036.      (setq face (if (boundp face) (symbol-value face) face)))
  1037.     (gnus-extent-start-open beg)))
  1038.     (goto-char p)))
  1039.  
  1040. ;;;
  1041. ;;; gnus-carpal
  1042. ;;;
  1043.  
  1044. (defvar gnus-carpal-group-buffer-buttons
  1045.   '(("next" . gnus-group-next-unread-group)
  1046.     ("prev" . gnus-group-prev-unread-group)
  1047.     ("read" . gnus-group-read-group)
  1048.     ("select" . gnus-group-select-group)
  1049.     ("catch-up" . gnus-group-catchup-current)
  1050.     ("new-news" . gnus-group-get-new-news-this-group)
  1051.     ("toggle-sub" . gnus-group-unsubscribe-current-group)
  1052.     ("subscribe" . gnus-group-unsubscribe-group)
  1053.     ("kill" . gnus-group-kill-group)
  1054.     ("yank" . gnus-group-yank-group)
  1055.     ("describe" . gnus-group-describe-group)
  1056.     "list"
  1057.     ("subscribed" . gnus-group-list-groups)
  1058.     ("all" . gnus-group-list-all-groups)
  1059.     ("killed" . gnus-group-list-killed)
  1060.     ("zombies" . gnus-group-list-zombies)
  1061.     ("matching" . gnus-group-list-matching)
  1062.     ("post" . gnus-group-post-news)
  1063.     ("mail" . gnus-group-mail)
  1064.     ("rescan" . gnus-group-get-new-news)
  1065.     ("browse-foreign" . gnus-group-browse-foreign)
  1066.     ("exit" . gnus-group-exit)))
  1067.  
  1068. (defvar gnus-carpal-summary-buffer-buttons
  1069.   '("mark" 
  1070.     ("read" . gnus-summary-mark-as-read-forward)
  1071.     ("tick" . gnus-summary-tick-article-forward)
  1072.     ("clear" . gnus-summary-clear-mark-forward)
  1073.     ("expirable" . gnus-summary-mark-as-expirable)
  1074.     "move"
  1075.     ("scroll" . gnus-summary-next-page)
  1076.     ("next-unread" . gnus-summary-next-unread-article)
  1077.     ("prev-unread" . gnus-summary-prev-unread-article)
  1078.     ("first" . gnus-summary-first-unread-article)
  1079.     ("best" . gnus-summary-best-unread-article)
  1080.     "article"
  1081.     ("headers" . gnus-summary-toggle-header)
  1082.     ("uudecode" . gnus-uu-decode-uu)
  1083.     ("enter-digest" . gnus-summary-enter-digest-group)
  1084.     ("fetch-parent" . gnus-summary-refer-parent-article)
  1085.     "mail"
  1086.     ("move" . gnus-summary-move-article)
  1087.     ("copy" . gnus-summary-copy-article)
  1088.     ("respool" . gnus-summary-respool-article)
  1089.     "threads"
  1090.     ("lower" . gnus-summary-lower-thread)
  1091.     ("kill" . gnus-summary-kill-thread)
  1092.     "post"
  1093.     ("post" . gnus-summary-post-news)
  1094.     ("mail" . gnus-summary-mail)
  1095.     ("followup" . gnus-summary-followup-with-original)
  1096.     ("reply" . gnus-summary-reply-with-original)
  1097.     ("cancel" . gnus-summary-cancel-article)
  1098.     "misc"
  1099.     ("exit" . gnus-summary-exit)
  1100.     ("fed-up" . gnus-summary-catchup-and-goto-next-group)))
  1101.  
  1102. (defvar gnus-carpal-server-buffer-buttons 
  1103.   '(("add" . gnus-server-add-server)
  1104.     ("browse" . gnus-server-browse-server)
  1105.     ("list" . gnus-server-list-servers)
  1106.     ("kill" . gnus-server-kill-server)
  1107.     ("yank" . gnus-server-yank-server)
  1108.     ("copy" . gnus-server-copy-server)
  1109.     ("exit" . gnus-server-exit)))
  1110.  
  1111. (defvar gnus-carpal-browse-buffer-buttons
  1112.   '(("subscribe" . gnus-browse-unsubscribe-current-group)
  1113.     ("exit" . gnus-browse-exit)))
  1114.  
  1115. (defvar gnus-carpal-group-buffer "*Carpal Group*")
  1116. (defvar gnus-carpal-summary-buffer "*Carpal Summary*")
  1117. (defvar gnus-carpal-server-buffer "*Carpal Server*")
  1118. (defvar gnus-carpal-browse-buffer "*Carpal Browse*")
  1119.  
  1120. (defvar gnus-carpal-attached-buffer nil)
  1121.  
  1122. (defvar gnus-carpal-mode-hook nil
  1123.   "*Hook run in carpal mode buffers.")
  1124.  
  1125. (defvar gnus-carpal-button-face 'bold
  1126.   "*Face used on carpal buttons.")
  1127.  
  1128. (defvar gnus-carpal-header-face 'bold-italic
  1129.   "*Face used on carpal buffer headers.")
  1130.  
  1131. (defvar gnus-carpal-mode-map nil)
  1132. (put 'gnus-carpal-mode 'mode-class 'special)
  1133.  
  1134. (if gnus-carpal-mode-map
  1135.     nil
  1136.   (setq gnus-carpal-mode-map (make-keymap))
  1137.   (suppress-keymap gnus-carpal-mode-map)
  1138.   (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
  1139.   (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
  1140.   (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
  1141.  
  1142. (defun gnus-carpal-mode ()
  1143.   "Major mode for clicking buttons.
  1144.  
  1145. All normal editing commands are switched off.
  1146. \\<gnus-carpal-mode-map>
  1147. The following commands are available:
  1148.  
  1149. \\{gnus-carpal-mode-map}"
  1150.   (interactive)
  1151.   (kill-all-local-variables)
  1152.   (setq mode-line-modified "-- ")
  1153.   (setq major-mode 'gnus-carpal-mode)
  1154.   (setq mode-name "Gnus Carpal")
  1155.   (setq mode-line-process nil)
  1156.   (use-local-map gnus-carpal-mode-map)
  1157.   (buffer-disable-undo (current-buffer))
  1158.   (setq buffer-read-only t)
  1159.   (make-local-variable 'gnus-carpal-attached-buffer)
  1160.   (run-hooks 'gnus-carpal-mode-hook))
  1161.  
  1162. (defun gnus-carpal-setup-buffer (type)
  1163.   (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
  1164.     (if (get-buffer buffer)
  1165.     ()
  1166.       (save-excursion
  1167.     (set-buffer (get-buffer-create buffer))
  1168.     (gnus-carpal-mode)
  1169.     (setq gnus-carpal-attached-buffer 
  1170.           (intern (format "gnus-%s-buffer" type)))
  1171.     (gnus-add-current-to-buffer-list)
  1172.     (let ((buttons (symbol-value 
  1173.             (intern (format "gnus-carpal-%s-buffer-buttons"
  1174.                     type))))
  1175.           (buffer-read-only nil)
  1176.           button)
  1177.       (while buttons
  1178.         (setq button (car buttons)
  1179.           buttons (cdr buttons))
  1180.         (if (stringp button)
  1181.         (gnus-set-text-properties
  1182.          (point)
  1183.          (prog2 (insert button) (point) (insert " "))
  1184.          (list 'face gnus-carpal-header-face))
  1185.           (gnus-set-text-properties
  1186.            (point)
  1187.            (prog2 (insert (car button)) (point) (insert " "))
  1188.            (list 'gnus-callback (cdr button)
  1189.              'face gnus-carpal-button-face
  1190.              gnus-mouse-face-prop 'highlight))))
  1191.       (let ((fill-column (- (window-width) 2)))
  1192.         (fill-region (point-min) (point-max)))
  1193.       (set-window-point (get-buffer-window (current-buffer)) 
  1194.                 (point-min)))))))
  1195.  
  1196. (defun gnus-carpal-select ()
  1197.   "Select the button under point."
  1198.   (interactive)
  1199.   (let ((func (get-text-property (point) 'gnus-callback)))
  1200.     (if (null func)
  1201.     ()
  1202.       (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
  1203.       (call-interactively func))))
  1204.  
  1205. (defun gnus-carpal-mouse-select (event)
  1206.   "Select the button under the mouse pointer."
  1207.   (interactive "e")
  1208.   (mouse-set-point event)
  1209.   (gnus-carpal-select))
  1210.  
  1211. ;;; 
  1212. ;;; article highlights
  1213. ;;;
  1214.  
  1215. ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
  1216.  
  1217. ;;; Internal Variables:
  1218.  
  1219. (defvar gnus-button-regexp nil)
  1220. ;; Regexp matching any of the regexps from `gnus-button-alist'.
  1221.  
  1222. (defvar gnus-button-last nil)
  1223. ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
  1224.  
  1225. ;;; Commands:
  1226.  
  1227. (defun gnus-article-push-button (event)
  1228.   "Check text under the mouse pointer for a callback function.
  1229. If the text under the mouse pointer has a `gnus-callback' property,
  1230. call it with the value of the `gnus-data' text property."
  1231.   (interactive "e")
  1232.   (set-buffer (window-buffer (posn-window (event-start event))))
  1233.   (let* ((pos (posn-point (event-start event)))
  1234.          (data (get-text-property pos 'gnus-data))
  1235.      (fun (get-text-property pos 'gnus-callback)))
  1236.     (if fun (funcall fun data))))
  1237.  
  1238. (defun gnus-article-press-button ()
  1239.   "Check text at point for a callback function.
  1240. If the text at point has a `gnus-callback' property,
  1241. call it with the value of the `gnus-data' text property."
  1242.   (interactive)
  1243.   (let* ((data (get-text-property (point) 'gnus-data))
  1244.      (fun (get-text-property (point) 'gnus-callback)))
  1245.     (if fun (funcall fun data))))
  1246.  
  1247. (defun gnus-article-prev-button (n)
  1248.   "Move point to N buttons backward.
  1249. If N is negative, move forward instead."
  1250.   (interactive "p")
  1251.   (gnus-article-next-button (- n)))
  1252.  
  1253. (defun gnus-article-next-button (n)
  1254.   "Move point to N buttons forward.
  1255. If N is negative, move backward instead."
  1256.   (interactive "p")
  1257.   (let ((function (if (< n 0) 'previous-single-property-change
  1258.             'next-single-property-change))
  1259.     (inhibit-point-motion-hooks t)
  1260.     (backward (< n 0))
  1261.     (limit (if (< n 0) (point-min) (point-max))))
  1262.     (setq n (abs n))
  1263.     (while (and (not (= limit (point)))
  1264.         (> n 0))
  1265.       ;; Skip past the current button.
  1266.       (when (get-text-property (point) 'gnus-callback)
  1267.     (goto-char (funcall function (point) 'gnus-callback nil limit)))
  1268.       ;; Go to the next (or previous) button.
  1269.       (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
  1270.       ;; Put point at the start of the button.
  1271.       (when (and backward (not (get-text-property (point) 'gnus-callback)))
  1272.     (goto-char (funcall function (point) 'gnus-callback nil limit)))
  1273.       ;; Skip past intangible buttons.
  1274.       (when (get-text-property (point) 'intangible)
  1275.     (incf n))
  1276.       (decf n))
  1277.     (unless (zerop n)
  1278.       (gnus-message 5 "No more buttons"))
  1279.     n))
  1280.  
  1281. (defun gnus-article-highlight (&optional force)
  1282.   "Highlight current article.
  1283. This function calls `gnus-article-highlight-headers',
  1284. `gnus-article-highlight-citation', 
  1285. `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
  1286. do the highlighting.  See the documentation for those functions."
  1287.   (interactive (list 'force))
  1288.   (gnus-article-highlight-headers)
  1289.   (gnus-article-highlight-citation force)
  1290.   (gnus-article-highlight-signature)
  1291.   (gnus-article-add-buttons force)
  1292.   (gnus-article-add-buttons-to-head))
  1293.  
  1294. (defun gnus-article-highlight-some (&optional force)
  1295.   "Highlight current article.
  1296. This function calls `gnus-article-highlight-headers',
  1297. `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
  1298. do the highlighting.  See the documentation for those functions."
  1299.   (interactive (list 'force))
  1300.   (gnus-article-highlight-headers)
  1301.   (gnus-article-highlight-signature)
  1302.   (gnus-article-add-buttons))
  1303.  
  1304. (defun gnus-article-highlight-headers ()
  1305.   "Highlight article headers as specified by `gnus-header-face-alist'."
  1306.   (interactive)
  1307.   (save-excursion
  1308.     (set-buffer gnus-article-buffer)
  1309.     (save-restriction
  1310.       (let ((alist gnus-header-face-alist)
  1311.         (buffer-read-only nil)
  1312.         (case-fold-search t)
  1313.         (inhibit-point-motion-hooks t)
  1314.         entry regexp header-face field-face from hpoints fpoints)
  1315.     (goto-char (point-min))
  1316.     (when (search-forward "\n\n" nil t)
  1317.       (narrow-to-region (1- (point)) (point-min))
  1318.       (while (setq entry (pop alist))
  1319.         (goto-char (point-min))
  1320.         (setq regexp (concat "^\\("
  1321.                  (if (string-equal "" (nth 0 entry))
  1322.                      "[^\t ]"
  1323.                    (nth 0 entry))
  1324.                  "\\)")
  1325.           header-face (nth 1 entry)
  1326.           field-face (nth 2 entry))
  1327.         (while (and (re-search-forward regexp nil t)
  1328.             (not (eobp)))
  1329.           (beginning-of-line)
  1330.           (setq from (point))
  1331.           (or (search-forward ":" nil t)
  1332.           (forward-char 1))
  1333.           (when (and header-face
  1334.              (not (memq (point) hpoints)))
  1335.         (push (point) hpoints)
  1336.         (gnus-put-text-property from (point) 'face header-face))
  1337.           (when (and field-face
  1338.              (not (memq (setq from (point)) fpoints)))
  1339.         (push from fpoints)
  1340.         (if (re-search-forward "^[^ \t]" nil t)
  1341.             (forward-char -2)
  1342.           (goto-char (point-max)))
  1343.         (gnus-put-text-property from (point) 'face field-face)))))))))
  1344.  
  1345. (defun gnus-article-highlight-signature ()
  1346.   "Highlight the signature in an article.
  1347. It does this by highlighting everything after
  1348. `gnus-signature-separator' using `gnus-signature-face'." 
  1349.   (interactive)
  1350.   (save-excursion
  1351.     (set-buffer gnus-article-buffer)
  1352.     (let ((buffer-read-only nil)
  1353.       (inhibit-point-motion-hooks t))
  1354.       (save-restriction
  1355.     (when (and gnus-signature-face
  1356.            (gnus-narrow-to-signature))
  1357.       (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
  1358.                 'face gnus-signature-face)
  1359.       (widen)
  1360.       (re-search-backward gnus-signature-separator nil t)
  1361.       (let ((start (match-beginning 0))
  1362.         (end (set-marker (make-marker) (1+ (match-end 0)))))
  1363.         (gnus-article-add-button start (1- end) 'gnus-signature-toggle
  1364.                      end)))))))
  1365.  
  1366. (defun gnus-article-add-buttons (&optional force)
  1367.   "Find external references in the article and make buttons of them.
  1368. \"External references\" are things like Message-IDs and URLs, as
  1369. specified by `gnus-button-alist'."
  1370.   (interactive (list 'force))
  1371.   (save-excursion
  1372.     (set-buffer gnus-article-buffer)
  1373.     ;; Remove all old markers.
  1374.     (while gnus-button-marker-list
  1375.       (set-marker (pop gnus-button-marker-list) nil))
  1376.     (let ((buffer-read-only nil)
  1377.       (inhibit-point-motion-hooks t)
  1378.       (case-fold-search t)
  1379.       (alist gnus-button-alist)
  1380.       beg entry regexp)
  1381.       (goto-char (point-min))
  1382.       ;; We skip the headers.
  1383.       (unless (search-forward "\n\n" nil t)
  1384.     (goto-char (point-max)))
  1385.       (setq beg (point))
  1386.       (while (setq entry (pop alist))
  1387.     (setq regexp (car entry))
  1388.     (goto-char beg)
  1389.     (while (re-search-forward regexp nil t)
  1390.       (let* ((start (and entry (match-beginning (nth 1 entry))))
  1391.          (end (and entry (match-end (nth 1 entry))))
  1392.          (from (match-beginning 0)))
  1393.         (when (or (eq t (nth 1 entry))
  1394.               (eval (nth 1 entry)))
  1395.           ;; That optional form returned non-nil, so we add the
  1396.           ;; button. 
  1397.           (gnus-article-add-button 
  1398.            start end 'gnus-button-push 
  1399.            (car (push (set-marker (make-marker) from)
  1400.               gnus-button-marker-list))))))))))
  1401.  
  1402. ;; Add buttons to the head of an article.
  1403. (defun gnus-article-add-buttons-to-head ()
  1404.   "Add buttons to the head of the article."
  1405.   (interactive)
  1406.   (save-excursion
  1407.     (set-buffer gnus-article-buffer)
  1408.     (let ((buffer-read-only nil)
  1409.       (inhibit-point-motion-hooks t)
  1410.       (case-fold-search t)
  1411.       (alist gnus-header-button-alist)
  1412.       entry beg end)
  1413.       (nnheader-narrow-to-headers)
  1414.       (while alist
  1415.     ;; Each alist entry.
  1416.     (setq entry (car alist)
  1417.           alist (cdr alist))
  1418.     (goto-char (point-min))
  1419.     (while (re-search-forward (car entry) nil t)
  1420.       ;; Each header matching the entry.
  1421.       (setq beg (match-beginning 0))
  1422.       (setq end (or (and (re-search-forward "^[^ \t]" nil t)
  1423.                  (match-beginning 0))
  1424.             (point-max)))
  1425.       (goto-char beg)
  1426.       (while (re-search-forward (nth 1 entry) end t)
  1427.         ;; Each match within a header.
  1428.         (let* ((from (match-beginning 0))
  1429.            (entry (cdr entry))
  1430.            (start (match-beginning (nth 1 entry)))
  1431.            (end (match-end (nth 1 entry)))
  1432.            (form (nth 2 entry)))
  1433.           (goto-char (match-end 0))
  1434.           (and (eval form)
  1435.            (gnus-article-add-button 
  1436.             start end (nth 3 entry)
  1437.             (buffer-substring (match-beginning (nth 4 entry))
  1438.                       (match-end (nth 4 entry)))))))
  1439.       (goto-char end))))
  1440.     (widen)))
  1441.  
  1442. ;;; External functions:
  1443.  
  1444. (defun gnus-article-add-button (from to fun &optional data)
  1445.   "Create a button between FROM and TO with callback FUN and data DATA."
  1446.   (and gnus-article-button-face
  1447.        (gnus-overlay-put (gnus-make-overlay from to)
  1448.              'face gnus-article-button-face))
  1449.   (gnus-add-text-properties 
  1450.    from to
  1451.    (nconc (and gnus-article-mouse-face
  1452.            (list gnus-mouse-face-prop gnus-article-mouse-face))
  1453.       (list 'gnus-callback fun)
  1454.       (and data (list 'gnus-data data)))))
  1455.  
  1456. ;;; Internal functions:
  1457.  
  1458. (defun gnus-signature-toggle (end)
  1459.   (save-excursion
  1460.     (set-buffer gnus-article-buffer)
  1461.     (let ((buffer-read-only nil)
  1462.       (inhibit-point-motion-hooks t))
  1463.       (if (get-text-property end 'invisible)
  1464.       (gnus-unhide-text end (point-max))
  1465.     (gnus-hide-text end (point-max) gnus-hidden-properties)))))
  1466.  
  1467. (defun gnus-button-entry ()
  1468.   ;; Return the first entry in `gnus-button-alist' matching this place.
  1469.   (let ((alist gnus-button-alist)
  1470.     (entry nil))
  1471.     (while alist
  1472.       (setq entry (pop alist))
  1473.       (if (looking-at (car entry))
  1474.       (setq alist nil)
  1475.     (setq entry nil)))
  1476.     entry))
  1477.  
  1478. (defun gnus-button-push (marker)
  1479.   ;; Push button starting at MARKER.
  1480.   (save-excursion
  1481.     (set-buffer gnus-article-buffer)
  1482.     (goto-char marker)
  1483.     (let* ((entry (gnus-button-entry))
  1484.        (inhibit-point-motion-hooks t)
  1485.        (fun (nth 3 entry))
  1486.        (args (mapcar (lambda (group) 
  1487.                (let ((string (buffer-substring
  1488.                       (match-beginning group)
  1489.                       (match-end group))))
  1490.                  (gnus-set-text-properties
  1491.                   0 (length string) nil string)
  1492.                  string))
  1493.              (nthcdr 4 entry))))
  1494.       (cond
  1495.        ((fboundp fun)
  1496.     (apply fun args))
  1497.        ((and (boundp fun)
  1498.          (fboundp (symbol-value fun)))
  1499.     (apply (symbol-value fun) args))
  1500.        (t
  1501.     (gnus-message 1 "You must define `%S' to use this button"
  1502.               (cons fun args)))))))
  1503.  
  1504. (defun gnus-button-message-id (message-id)
  1505.   "Fetch MESSAGE-ID."
  1506.   (save-excursion
  1507.     (set-buffer gnus-summary-buffer)
  1508.     (gnus-summary-refer-article message-id)))
  1509.  
  1510. (defun gnus-button-mailto (address)
  1511.   ;; Mail to ADDRESS.
  1512.   (set-buffer (gnus-copy-article-buffer))
  1513.   (message-reply address))
  1514.  
  1515. (defun gnus-button-reply (address)
  1516.   ;; Reply to ADDRESS.
  1517.   (message-reply address))
  1518.  
  1519. (defun gnus-button-url (address)
  1520.   "Browse ADDRESS."
  1521.   (funcall browse-url-browser-function address))
  1522.  
  1523. ;;; Next/prev buttons in the article buffer.
  1524.  
  1525. (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
  1526. (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
  1527.  
  1528. (defvar gnus-prev-page-map nil)
  1529. (unless gnus-prev-page-map
  1530.   (setq gnus-prev-page-map (make-sparse-keymap))
  1531.   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
  1532.   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
  1533.  
  1534. (defun gnus-insert-prev-page-button ()
  1535.   (let ((buffer-read-only nil))
  1536.     (gnus-eval-format 
  1537.      gnus-prev-page-line-format nil
  1538.      `(gnus-prev t local-map ,gnus-prev-page-map
  1539.          gnus-callback gnus-article-button-prev-page))))
  1540.  
  1541. (defvar gnus-next-page-map nil)
  1542. (unless gnus-next-page-map
  1543.   (setq gnus-next-page-map (make-keymap))
  1544.   (suppress-keymap gnus-prev-page-map)
  1545.   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
  1546.   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
  1547.  
  1548. (defun gnus-button-next-page ()
  1549.   "Go to the next page."
  1550.   (interactive)
  1551.   (let ((win (selected-window)))
  1552.     (select-window (get-buffer-window gnus-article-buffer t))
  1553.     (gnus-article-next-page)
  1554.     (select-window win)))
  1555.  
  1556. (defun gnus-button-prev-page ()
  1557.   "Go to the prev page."
  1558.   (interactive)
  1559.   (let ((win (selected-window)))
  1560.     (select-window (get-buffer-window gnus-article-buffer t))
  1561.     (gnus-article-prev-page)
  1562.     (select-window win)))
  1563.  
  1564. (defun gnus-insert-next-page-button ()
  1565.   (let ((buffer-read-only nil))
  1566.     (gnus-eval-format gnus-next-page-line-format nil
  1567.               `(gnus-next t local-map ,gnus-next-page-map
  1568.                   gnus-callback 
  1569.                   gnus-article-button-next-page))))
  1570.  
  1571. (defun gnus-article-button-next-page (arg)
  1572.   "Go to the next page."
  1573.   (interactive "P")
  1574.   (let ((win (selected-window)))
  1575.     (select-window (get-buffer-window gnus-article-buffer t))
  1576.     (gnus-article-next-page)
  1577.     (select-window win)))
  1578.  
  1579. (defun gnus-article-button-prev-page (arg)
  1580.   "Go to the prev page."
  1581.   (interactive "P")
  1582.   (let ((win (selected-window)))
  1583.     (select-window (get-buffer-window gnus-article-buffer t))
  1584.     (gnus-article-prev-page)
  1585.     (select-window win)))
  1586.  
  1587. ;;; Compatibility Functions:
  1588.  
  1589. (or (fboundp 'rassoc)
  1590.     ;; Introduced in Emacs 19.29.
  1591.     (defun rassoc (elt list)
  1592.       "Return non-nil if ELT is `equal' to the cdr of an element of LIST.
  1593. The value is actually the element of LIST whose cdr is ELT."
  1594.       (let (result)
  1595.     (while list
  1596.       (setq result (car list))
  1597.       (if (equal (cdr result) elt)
  1598.           (setq list nil)
  1599.         (setq result nil
  1600.           list (cdr list))))
  1601.     result)))
  1602.  
  1603. ; (require 'gnus-cus)
  1604. (gnus-ems-redefine)
  1605. (provide 'gnus-vis)
  1606.  
  1607. ;;; gnus-vis.el ends here
  1608.